home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 2.iso / dist / fw_guile.idb / usr / freeware / share / guile / 1.4 / ice-9 / emacs.scm.z / emacs.scm
Text File  |  2002-07-08  |  8KB  |  264 lines
  1. ;;;;     Copyright (C) 1996, 1997, 1998, 1999 Free Software Foundation, Inc.
  2. ;;;; 
  3. ;;;; This program is free software; you can redistribute it and/or modify
  4. ;;;; it under the terms of the GNU General Public License as published by
  5. ;;;; the Free Software Foundation; either version 2, or (at your option)
  6. ;;;; any later version.
  7. ;;;; 
  8. ;;;; This program is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. ;;;; GNU General Public License for more details.
  12. ;;;; 
  13. ;;;; You should have received a copy of the GNU General Public License
  14. ;;;; along with this software; see the file COPYING.  If not, write to
  15. ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16. ;;;; Boston, MA 02111-1307 USA
  17. ;;;;
  18. ;;;; The author can be reached at djurfeldt@nada.kth.se
  19. ;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
  20. ;;;; (I didn't write this!)
  21. ;;;;
  22.  
  23.  
  24. ;;; *********************************************************************
  25. ;;; * This is the Guile side of the Emacs interface                     *
  26. ;;; * Experimental hACK---the real version will be coming soon (almost) *
  27. ;;; *********************************************************************
  28.  
  29. ;;; {Session support for Emacs}
  30. ;;;
  31.  
  32. (define-module (ice-9 emacs)
  33.   :use-module (ice-9 debug)
  34.   :use-module (ice-9 threads)
  35.   :use-module (ice-9 session)
  36.   :no-backtrace)
  37.  
  38. (define emacs-escape-character #\sub)
  39.  
  40. (define emacs-output-port (current-output-port))
  41.  
  42. (define (make-emacs-command char)
  43.   (let ((cmd (list->string (list emacs-escape-character char))))
  44.     (lambda ()
  45.       (display cmd emacs-output-port))))
  46.  
  47. (define enter-input-wait  (make-emacs-command #\s))
  48. (define exit-input-wait   (make-emacs-command #\f))
  49. (define enter-read-character #\r)
  50. (define sending-error      (make-emacs-command #\F))
  51. (define sending-backtrace (make-emacs-command #\B))
  52. (define sending-result    (make-emacs-command #\x))
  53. (define end-of-text      (make-emacs-command #\.))
  54. (define no-stack      (make-emacs-command #\S))
  55. (define no-source      (make-emacs-command #\R))
  56.  
  57. ;; {Error handling}
  58. ;;
  59.  
  60. (add-hook! before-backtrace-hook sending-backtrace)
  61. (add-hook! after-backtrace-hook end-of-text)
  62. (add-hook! before-error-hook sending-error)
  63. (add-hook! after-error-hook end-of-text)
  64.  
  65. ;; {Repl}
  66. ;;
  67.  
  68. (set-current-error-port emacs-output-port)
  69.  
  70. (add-hook! before-read-hook
  71.        (lambda ()
  72.          (enter-input-wait)
  73.          (force-output emacs-output-port)))
  74.  
  75. (add-hook! after-read-hook
  76.        (lambda ()
  77.          (exit-input-wait)
  78.          (force-output emacs-output-port)))
  79.  
  80. ;;; {Misc.}
  81.  
  82. (define (make-emacs-load-port orig-port)
  83.   (letrec ((read-char-fn  (lambda args
  84.                 (let ((c (read-char orig-port)))
  85.                   (if (eq? c #\soh)
  86.                   (throw 'end-of-chunk)
  87.                   c)))))
  88.     
  89.     (make-soft-port
  90.      (vector #f #f #f
  91.          read-char-fn
  92.          (lambda () (close-port orig-port)))
  93.      "r")))
  94.  
  95. (set-current-input-port (make-emacs-load-port (current-input-port)))
  96.  
  97. (define (result-to-emacs exp)
  98.   (sending-result)
  99.   (write exp emacs-output-port)
  100.   (end-of-text)
  101.   (force-output emacs-output-port))
  102.  
  103. (define load-acknowledge (make-emacs-command #\l))
  104.  
  105. (define load-port (current-input-port))
  106.  
  107. (define (flush-line port)
  108.   (let loop ((c (read-char port)))
  109.     (if (not (eq? c #\nl))
  110.     (loop (read-char port)))))
  111.  
  112. (define whitespace-chars (list #\space #\tab #\nl #\np))
  113.  
  114. (define (flush-whitespace port)
  115.   (catch 'end-of-chunk
  116.      (lambda ()
  117.        (let loop ((c (read-char port)))
  118.          (cond ((eq? c the-eof-object)
  119.             (error "End of file while recieving Emacs data"))
  120.            ((memq c whitespace-chars) (loop (read-char port)))
  121.            ((eq? c #\;) (flush-line port) (loop (read-char port)))
  122.            (else (unread-char c port))))
  123.        #f)
  124.      (lambda args
  125.        (read-char port) ; Read final newline
  126.        #t)))
  127.  
  128. (define (emacs-load filename linum colnum module interactivep)
  129.   (set-port-filename! %%load-port filename)
  130.   (set-port-line! %%load-port linum)
  131.   (set-port-column! %%load-port colnum)
  132.   (lazy-catch #t
  133.           (lambda ()
  134.         (let loop ((endp (flush-whitespace %%load-port)))
  135.           (if (not endp)
  136.               (begin
  137.             (save-module-excursion
  138.              (lambda ()
  139.                (if module
  140.                    (set-current-module (resolve-module module #f)))
  141.                (let ((result
  142.                   (start-stack read-and-eval!
  143.                            (read-and-eval! %%load-port))))
  144.                  (if interactivep
  145.                  (result-to-emacs result)))))
  146.             (loop (flush-whitespace %%load-port)))
  147.               (begin
  148.             (load-acknowledge)))
  149.           (set-port-filename! %%load-port #f)))    ;reset port filename
  150.           (lambda (key . args)
  151.         (set-port-filename! %%load-port #f)
  152.         (cond ((eq? key 'end-of-chunk)
  153.                (fluid-set! the-last-stack #f)
  154.                (set! stack-saved? #t)
  155.                (scm-error 'misc-error
  156.                   #f
  157.                   "Incomplete expression"
  158.                   '()
  159.                   '()))
  160.               ((eq? key 'exit))
  161.               (else
  162.                (save-stack 2)
  163.                (catch 'end-of-chunk
  164.                   (lambda ()
  165.                 (let loop ()
  166.                   (read-char %%load-port)
  167.                   (loop)))
  168.                   (lambda args
  169.                 #f))
  170.                (apply throw key args))))))
  171.  
  172. (define (emacs-eval-request form)
  173.   (result-to-emacs (eval form)))
  174.  
  175. ;;*fixme* Not necessary to use flags no-stack and no-source
  176. (define (get-frame-source frame)
  177.   (if (or (not (fluid-ref the-last-stack))
  178.       (>= frame (stack-length (fluid-ref the-last-stack))))
  179.       (begin
  180.     (no-stack)
  181.     #f)
  182.       (let* ((frame (stack-ref (fluid-ref the-last-stack)
  183.                    (frame-number->index frame)))
  184.          (source (frame-source frame)))
  185.     (or source
  186.         (begin (no-source)
  187.            #f)))))
  188.  
  189. (define (emacs-select-frame frame)
  190.   (let ((source (get-frame-source frame)))
  191.     (if source
  192.     (let ((fname (source-property source 'filename))
  193.           (line (source-property source 'line))
  194.           (column (source-property source 'column)))
  195.       (if (and fname line column)
  196.           (list fname line column)
  197.           (begin (no-source)
  198.              '())))
  199.     '())))
  200.  
  201. (define (object->string x . method)
  202.   (with-output-to-string
  203.     (lambda ()
  204.       ((if (null? method)
  205.        write
  206.        (car method))
  207.        x))))
  208.  
  209. (define (format template . rest)
  210.   (let loop ((chars (string->list template))
  211.          (result '())
  212.          (rest rest))
  213.     (cond ((null? chars) (list->string (reverse result)))
  214.       ((char=? (car chars) #\%)
  215.        (loop (cddr chars)
  216.          (append (reverse
  217.               (string->list
  218.                (case (cadr chars)
  219.                  ((#\S) (object->string (car rest)))
  220.                  ((#\s) (object->string (car rest) display)))))
  221.              result)
  222.          (cdr rest)))
  223.       (else (loop (cdr chars) (cons (car chars) result) rest)))))
  224.  
  225. (define (error-args->string args)
  226.   (let ((msg (apply format (caddr args) (cadddr args))))
  227.     (if (symbol? (cadr args))
  228.     (string-append (symbol->string (cadr args))
  229.                ": "
  230.                msg)
  231.     msg)))
  232.  
  233. (define (emacs-frame-eval frame form)
  234.   (let ((source (get-frame-source frame)))
  235.     (if source
  236.     (catch #t
  237.            (lambda ()
  238.          (list 'result
  239.                (object->string
  240.             (local-eval (with-input-from-string form read)
  241.                     (memoized-environment source)))))
  242.            (lambda args
  243.          (list (car args)
  244.                (error-args->string args))))
  245.     (begin
  246.       (no-source)
  247.       '()))))
  248.  
  249. (define (emacs-symdoc symbol)
  250.   (if (or (not (module-bound? (current-module) symbol))
  251.       (not (procedure? (eval symbol))))
  252.       'nil
  253.       (procedure-documentation (eval symbol))))
  254.  
  255. ;;; A fix to get the emacs interface to work together with the module system.
  256. ;;;
  257. (variable-set! (builtin-variable '%%load-port) load-port)
  258. (variable-set! (builtin-variable '%%emacs-load) emacs-load)
  259. (variable-set! (builtin-variable '%%emacs-eval-request) emacs-eval-request)
  260. (variable-set! (builtin-variable '%%emacs-select-frame) emacs-select-frame)
  261. (variable-set! (builtin-variable '%%emacs-frame-eval) emacs-frame-eval)
  262. (variable-set! (builtin-variable '%%emacs-symdoc) emacs-symdoc)
  263. (variable-set! (builtin-variable '%%apropos-internal) apropos-internal)
  264.